home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / tbproc.arc / TPRO1.PAS next >
Encoding:
Pascal/Delphi Source File  |  1985-08-16  |  19.3 KB  |  592 lines
  1.  
  2.  
  3.                    T P R O    N U M B E R    1
  4.  
  5.    The following is a set of procedures that we have been used in
  6. various commercial programs. Feel free to use them for commercial
  7. and noncomercial uses. We claim no responsibility to the outcome of
  8. the use of these procedures. You are using them at your own risk.
  9. Enough of the legalities. If you find these routines useful, we
  10. would greatly appreciate any small donation.
  11.  
  12.  
  13.  
  14.  
  15.                                 Soft-Touch Computers
  16.                                 James Billmeyer
  17.                                 7716 Balboa Blvd, Unit D
  18.                                 Van Nuys, Ca  91406
  19.  
  20.  
  21.  
  22.  
  23.  
  24. (****************************************************************)
  25. (*  The following set of procedures is a  include file that is  *)
  26. (*  used to handle screen I/O very rapidly.  The screen_colors  *)
  27. (*  procedure is used  to  set  the forground  and  background  *)
  28. (*  colors for the fprint  and  bprint procedures.  The fprint  *)
  29. (*  procedure writes directly  to  the graphics screen memory.  *)
  30. (*  The fprint procedure is about 3 to 7 times faster then the  *)
  31. (*  Turbo Pascal write/writeln routines.                        *)
  32. (*                                                              *)
  33. (*  The rest of the procedures  are  screen handling routines.  *)
  34. (*  They are used to take a screen file from a  disk drive and  *)
  35. (*  save  them  on  the  heap.  When  a  screen  is  need  for  *)
  36. (*  displaying, the screen  is  retrieved from  the  heap  and  *)
  37. (*  placed in  the image_buffer  by  the get_screen_from_stack  *)
  38. (*  procedure.  Text can  then be added  to  the screen in the  *)
  39. (*  image_buffer with  the  bprint procedure.  When the screen  *)
  40. (*  is finish being modified in  the image_buffer,  if is then  *)
  41. (*  transfered to the graphics display memory by the procedure  *)
  42. (*  send_buffer_to_screen.                                      *)
  43. (*                                                              *)
  44. (*  An example of the program that is needed to create a screen *)
  45. (*  files, and an example segment that  shows  the  routines in *)
  46. (*  use is given after screen handling procedures.              *)
  47. (*                                                              *)
  48. (****************************************************************)
  49.  
  50. (************************************************)
  51. (*  Begining Screen window  include procedures  *)
  52. (************************************************)
  53.  
  54.  
  55.  
  56. type
  57.    imagetype    = array[1..4096] of char;
  58.    str80        = string[80];
  59.    str12        = string[12];
  60.    screenptr    = ^screenrecord;
  61.    screenrecord = record
  62.                      screen :  imagetype;
  63.                      next   :  screenptr;
  64.                   end;
  65.  
  66. var
  67.    colorbuffer   :  imagetype absolute $b800:$0000;
  68.    image_buffer  :  imagetype;
  69.    i,row,col     :  integer;
  70.    color,bgcolor :  byte;
  71.    _screen       :  file;
  72.    screens,top   :  screenptr;
  73.  
  74.  
  75. procedure screen_colors(fcolor,bgcolor: byte; var color: byte);
  76.  
  77. begin
  78.    if fcolor > 15  then
  79.       begin
  80.          fcolor := fcolor - 16;
  81.          color  := fcolor + (bgcolor * 16) + 128 ;
  82.       end
  83.    else
  84.       color := fcolor + (bgcolor * 16);
  85. end;
  86.  
  87.  
  88.  
  89. procedure fprint(_string: str80; row,col: integer);
  90.  
  91. var
  92.    i,j,
  93.    first,
  94.    offset,
  95.    strlength :  integer;
  96.  
  97. begin
  98.    offset := $8000 + ((row - 1) * 160) + ((col - 1) * 2);
  99.    strlength := length(_string);
  100.    if  strlength < 4  then
  101.       first := strlength
  102.    else
  103.       first := strlength div 2;
  104.    i := 1;
  105.    while (i < first) or (i = 1) do
  106.       if  (port[$3DA] and $8) > 0  then
  107.          begin
  108.             repeat
  109.                memw[$B000:offset] := color shl 8 + ord(_string[i]);
  110.                offset := offset + 2;
  111.                i := i + 1;
  112.             until  i > first;
  113.          end;
  114.    while (i < strlength) and (i > first) do
  115.       if  (port[$3DA] and $8) > 0  then
  116.          begin
  117.             repeat
  118.                memw[$B000:offset] := color shl 8 + ord(_string[i]);
  119.                offset := offset + 2;
  120.                i := i + 1;
  121.             until  i > strlength;
  122.          end;
  123. end;
  124.  
  125.  
  126.  
  127. procedure bprint(var buffer: imagetype; _string: str80; row,col: integer);
  128.  
  129. var
  130.    i,j,offset :  integer;
  131.  
  132. begin
  133.    offset := ofs(buffer) + ((row - 1) * 160) + ((col - 1) * 2);
  134.    i := 1;
  135.    for  i := 1  to  length(_string)  do
  136.       begin
  137.          mem[seg(buffer):offset]     := ord(_string[i]);
  138.          mem[seg(buffer):offset + 1] := color;
  139.          offset := offset + 2;
  140.       end;
  141. end;
  142.  
  143.  
  144.  
  145.  
  146.  
  147. procedure load_screen_stack(    screen_file_name  :  str12;
  148.                                 number_of_screens :  integer;
  149.                             var top               :  screenptr);
  150.  
  151. (**************************************************)
  152. (*  The  load_screen_stack procedure  builds the  *)
  153. (*  stack of screens used by this program.        *)
  154. (**************************************************)
  155.  
  156. var
  157.    next_screen :  screenptr;
  158.  
  159. begin
  160.    assign(_screen,screen_file_name);
  161.    reset(_screen);
  162.    new(top);
  163.    screens := top;
  164.    blockread(_screen,screens^.screen,32);
  165.    for  i := 1  to  number_of_screens - 1  do
  166.       begin
  167.          new(next_screen);
  168.          screens^.next := next_screen;
  169.          screens := next_screen;
  170.          blockread(_screen,screens^.screen,32);
  171.       end;
  172.    screens^.next := nil;
  173.    close(_screen);
  174. end;
  175.  
  176.  
  177. procedure get_screen_from_stack(    screen_number :  integer;
  178.                                 var image_buffer  :  imagetype;
  179.                                     top           :  screenptr);
  180.  
  181. (**************************************************)
  182. (*  The  get_screen_from_stack procedure get the  *)
  183. (*  wanted screen off  of  the screen  stack and  *)
  184. (*  places it in the screen buffer.               *)
  185. (**************************************************)
  186.  
  187. var
  188.    i    :  integer;
  189.    next :  screenptr;
  190.  
  191. begin
  192.    i := 1;
  193.    screens := top;
  194.    while  i < screen_number  do
  195.       begin
  196.          screens := screens^.next;
  197.          i := i + 1;
  198.       end;
  199.    image_buffer := screens^.screen;
  200. end;
  201.  
  202.  
  203. procedure send_buffer_to_screen(image_buffer: imagetype);
  204.  
  205. (**************************************************)
  206. (*  The  send_buffer_to_screen  procedure  takes  *)
  207. (*  image_buffer  and  sends  it  to  the screen  *)
  208. (*  buffer.                                       *)
  209. (**************************************************)
  210.  
  211. var
  212.    i :  integer;
  213.  
  214. begin
  215.    i := 0;
  216.    repeat
  217.       if  (port[$3DA] and $8) > 0  then
  218.          begin
  219.             port[$3D8] := 33;
  220.             colorbuffer := image_buffer;
  221.             port[$3D8] := 41;
  222.             i := i + 1;
  223.          end;
  224.    until  i > 0;
  225. end;
  226.  
  227.  
  228.  
  229. (**************************************************)
  230. (*  End of the Screen window  include procedures  *)
  231. (**************************************************)
  232.  
  233.  
  234.  
  235. program mcisc(input,output);
  236.  
  237. (**************************)
  238. (*  Screen saver program  *)
  239. (**************************)
  240.  
  241. const
  242.    number_of_screens = 3;
  243.  
  244. type
  245.    imagetype    = array[1..4096] of char;
  246.    str80        = string[80];
  247.    str10        = string[10];
  248.  
  249. var
  250.    colorbuffer   :  imagetype absolute $b800:$0000;
  251.    image_buffer  :  imagetype;
  252.    i,j           :  integer;
  253.    save_screen   :  file;
  254.  
  255.  
  256.  
  257. Procedure print_mci_info_headers;
  258.  
  259. (**************************************************)
  260. (*  The print_mci_info_headers  Procedure prints  *)
  261. (*  information  titles  In column  form  on the  *)
  262. (*  screen.                                       *)
  263. (**************************************************)
  264.  
  265. Var
  266.    line_205 :  String[28];
  267.    line_196 :  String[51];
  268.  
  269. Begin
  270.    fillchar(line_205,28,Chr(205));
  271.    fillchar(line_196,51,Chr(196));
  272.    textcolor(white);
  273.    textbackground(lightgray);
  274.    gotoxy(25,1);  Writeln(Chr(201),copy(line_205,1,27),Chr(187));
  275.    gotoxy(25,2);  Writeln(Chr(186),'  MCI Dialing Information  ',Chr(186));
  276.    gotoxy(14,3);  Writeln(Chr(218),copy(line_196,1,10),Chr(200),copy(line_205,1,27),Chr(188),copy(line_196,1,10),Chr(191));
  277.    gotoxy(14,4);  Writeln(Chr(179),'                                                 ',Char(179));
  278.    gotoxy(14,5);  Writeln(Chr(179),'   Name/Title:                                   ',Char(179));
  279.    gotoxy(14,6);  Writeln(Chr(179),'                                                 ',Char(179));
  280.    gotoxy(14,7);  Writeln(Chr(179),'    User Name:                                   ',Char(179));
  281.    gotoxy(14,8);  Writeln(Chr(179),'                                                 ',Char(179));
  282.    gotoxy(14,9);  Writeln(Chr(179),'     Password:                                   ',Char(179));
  283.    gotoxy(14,10); Writeln(Chr(179),'                                                 ',Char(179));
  284.    gotoxy(14,11); Writeln(Chr(179),'    Telephone:                                   ',Char(179));
  285.    gotoxy(14,12); Writeln(Chr(179),'                                                 ',Char(179));
  286.    gotoxy(14,13); Writeln(Chr(179),'      Local                                      ',Char(179));
  287.    gotoxy(14,14); Writeln(Chr(179),'    Area Code:                                   ',Char(179));
  288.    gotoxy(14,15); Writeln(Chr(179),'                                                 ',Char(179));
  289.    gotoxy(14,16); Writeln(Chr(192),copy(line_196,1,49),Chr(217));
  290.    textcolor(white);
  291.    textbackground(lightgray);
  292.    gotoxy(26,2);  Writeln('  MCI Dialing Information  ');
  293.    textcolor(lightcyan);
  294.    textbackground(black);
  295.    gotoxy(15,4);  Writeln('                                                 ');
  296.    gotoxy(15,5);  Writeln('   Name/Title:                                   ');
  297.    gotoxy(15,6);  Writeln('                                                 ');
  298.    gotoxy(15,7);  Writeln('    User Name:                                   ');
  299.    gotoxy(15,8);  Writeln('                                                 ');
  300.    gotoxy(15,9);  Writeln('     Password:                                   ');
  301.    gotoxy(15,10); Writeln('                                                 ');
  302.    gotoxy(15,11); Writeln('    Telephone:                                   ');
  303.    gotoxy(15,12); Writeln('                                                 ');
  304.    gotoxy(15,13); Writeln('      Local                                      ');
  305.    gotoxy(15,14); Writeln('    Area Code:                                   ');
  306.    gotoxy(15,15); Writeln('                                                 ');
  307.    textcolor(black);
  308.    textbackground(lightmagenta);
  309.    gotoxy(8,25); Write('        ');
  310.    gotoxy(17,25); Write(' date:            time:          ');
  311.    gotoxy(51,25); Write('          ');
  312.    gotoxy(62,25); Write('           ');
  313.    textbackground(black);
  314.    textcolor(lightgray)
  315. End;
  316.  
  317.  
  318.  
  319. Procedure print_cust_menu;
  320.  
  321. (*******************************************************)
  322. (*  The print_cust_menu Procedure prints the programs  *)
  323. (*  menu.                                              *)
  324. (*******************************************************)
  325.  
  326. Var
  327.    line_196 : String[17];
  328.  
  329. Begin
  330.    gotoxy(31,16); Write('              ');
  331.    window(31,13,46,24);
  332.    fillchar(line_196,17,196);
  333.    textcolor(lightblue);
  334.    textbackground(blue);
  335.    gotoxy(31,13);
  336.    gotoxy(1,11);
  337.    Write(Char(218),copy(line_196,1,14),Char(191));
  338.    Write( Char(179),'  - Press -   ',Char(179));
  339.    Write(Char(195),copy(line_196,1,14),Char(180));
  340.    Write( Char(179),' A..add       ',Char(179));
  341.    Write( Char(179),' C..carry',Chr(26),'add ',Char(179));
  342.    Write( Char(179),' E..edit      ',Char(179));
  343.    Write( Char(179),' D..delete    ',Char(179));
  344.    Write( Char(179),' F..forward   ',Char(179));
  345.    Write( Char(179),' B..backward  ',Char(179));
  346.    Write( Char(179),' X..Exit      ',Char(179));
  347.    Write(Char(192),copy(line_196,1,14),Char(217));
  348.    textcolor(white);
  349.    gotoxy(2,2); Write('  - Press -   ');
  350.    textcolor(yellow);
  351.    textbackground(blue);
  352.    gotoxy(2,4); Write(' A..add       ');
  353.    gotoxy(2,5); Write(' C..carry',Chr(26),'add ');
  354.    gotoxy(2,6); Write(' E..edit      ');
  355.    gotoxy(2,7); Write(' D..delete    ');
  356.    gotoxy(2,8); Write(' F..forward   ');
  357.    gotoxy(2,9); Write(' B..backward  ');
  358.    gotoxy(2,10); Write(' X..Exit      ');
  359.    window(1,1,80,25);
  360.    textcolor(white);
  361.    textbackground(black);
  362.    gotoxy(31,24); write('                      ');
  363. End;
  364.  
  365.  
  366.  
  367. Procedure print_old_mci_rec_window;
  368.  
  369. (**************************************************)
  370. (*  The display Record Procedure prints a Record  *)
  371. (*  on the screen.                                *)
  372. (**************************************************)
  373.  
  374. Const
  375.    space = '                                ';
  376.  
  377. Var
  378.    line_205,
  379.    line_196 :  String[35];
  380.  
  381. Begin
  382.    fillchar(line_205,35,Chr(205));
  383.    fillchar(line_196,35,Chr(196));
  384.    window(46,11,80,23);
  385.    gotoxy(46,11);
  386.    gotoxy(1,1);
  387.    textcolor(lightgreen);
  388.    textbackground(green);
  389.    Write(Chr(201),copy(line_205,1,33),Chr(187));
  390.    Write(Chr(186),' .Similar  MCI  account on file. ',Chr(186));
  391.    Write(Chr(199),copy(line_196,1,33),Chr(182));
  392.    Write(Chr(186),' Name/Title:                     ',Chr(186));
  393.    Write(Chr(186),'  User Name:                     ',Chr(186));
  394.    Write(Chr(186),'   Password:                     ',Chr(186));
  395.    Write(Chr(186),'  Telephone:                     ',Chr(186));
  396.    Write(Chr(186),'    Local                        ',Chr(186));
  397.    Write(Chr(186),'  Area Code:                     ',Chr(186));
  398.    Write(Chr(199),copy(line_196,1,33),Chr(182));
  399.    Write(Chr(186),'                                 ',Chr(186));
  400.    Write(Chr(200),copy(line_205,1,33),Chr(188));
  401.    textcolor(white);
  402.    textbackground(green);
  403.    gotoxy(2,2); Write(' .Similar  MCI  account on file. ');
  404.    textcolor(yellow);
  405.    textbackground(black);
  406.    gotoxy(2,4); Write(' Name/Title:                     ');
  407.    gotoxy(2,5); Write('  User Name:                     ');
  408.    gotoxy(2,6); Write('   Password:                     ');
  409.    gotoxy(2,7); Write('  Telephone:                     ');
  410.    gotoxy(2,8); Write('    Local                        ');
  411.    gotoxy(2,9); Write('  Area Code:                     ');
  412.    window(1,1,80,25);
  413. End;
  414.  
  415.  
  416.  
  417. Procedure print_To_End_edit;
  418.  
  419. (**************************************************)
  420. (*  The  print_To_End_edit Procedure  prints the  *)
  421. (*  how To End edit reminder.                     *)
  422. (**************************************************)
  423.  
  424. Var
  425.    line_196  :  String[19];
  426.  
  427. Begin
  428.    fillchar(line_196,19,Chr(196));
  429.    window(60,10,79,13);
  430.    gotoxy(60,10);
  431.    gotoxy(1,1);
  432.    textcolor(lightmagenta);
  433.    textbackground(magenta);
  434.    Writeln(Chr(218),copy(line_196,1,17),Chr(191));
  435.    Writeln(Chr(179),' To EXIT press * ',Chr(179));
  436.    Writeln(Chr(192),copy(line_196,1,17),Chr(217));
  437.    textcolor(white);
  438.    gotoxy(2,2); Writeln(' To EXIT press * ');
  439.    textcolor(lightgray);
  440.    textbackground(black);
  441.    window(1,1,80,25);
  442. End;
  443.  
  444.  
  445.  
  446. begin
  447.    assign(save_screen,'MCI.SCR');
  448.    rewrite(save_screen);
  449.    clrscr;
  450.    print_mci_info_headers;
  451.    blockwrite(save_screen,colorbuffer,32);
  452.    clrscr;
  453.    print_mci_info_headers;
  454.    print_to_end_edit;
  455.    blockwrite(save_screen,colorbuffer,32);
  456.    clrscr;
  457.    print_mci_info_headers;
  458.    print_old_mci_rec_window;
  459.    print_cust_menu;
  460.    blockwrite(save_screen,colorbuffer,32);
  461.    clrscr;
  462.    close(save_screen);
  463.    assign(save_screen,'MCI.SCR');
  464.    reset(save_screen);
  465.    for  i := 1  to  number_of_screens  do
  466.       begin
  467.          blockread(save_screen,image_buffer,32);
  468.          j := 0;
  469.          repeat
  470.             if  (port[$3DA] and $8) > 0  then
  471.                begin
  472.                   port[$3D8] := 33;
  473.                   colorbuffer := image_buffer;
  474.                   port[$3D8] := 41;
  475.                   j := j + 1;
  476.                end;
  477.          until  j > 0;
  478.          delay(2000);
  479.       end;
  480. end.
  481.  
  482.  
  483. (*********************************************************)
  484. (*  An example of the screen handling procedures in use  *)
  485. (*********************************************************)
  486.  
  487.  
  488.  
  489. procedure makewindow(window_number,option: integer);
  490.  
  491. (**************************************************)
  492. (*  the make_window procedure gets a screen from  *)
  493. (*  the screen stack and fills in the nessessary  *)
  494. (*  information.                                  *)
  495. (**************************************************)
  496.  
  497. const
  498.    space = '                   ';
  499.  
  500. begin
  501.    screen_colors(white,black,color);
  502.    get_screen_from_stack(window_number,image_buffer,top);
  503.    case  option  of
  504.       1,4 : begin   (* display_old_mci_rec *)
  505.              clear_mci_info(mci_info);
  506.              getrec(mci_data,recnumber,mci_info);
  507.              with  mci_info  do
  508.                 begin
  509.                    if  option = 4  then
  510.                       begin
  511.                          bprint(image_buffer,copy((mci_name),1,20),5,30);
  512.                       end;
  513.                    bprint(image_buffer,copy((mci_name + space),1,19),14,60);
  514.                    bprint(image_buffer,copy((mci_user + space),1,19),15,60);
  515.                    bprint(image_buffer,copy((mci_password + space),1,19),16,60);
  516.                    bprint(image_buffer,copy((mci_telephone + space),1,19),17,60);
  517.                    bprint(image_buffer,copy((mci_local_area + space),1,19),19,60);
  518.                end;
  519.           end;
  520.  
  521.       2,3 : begin   (* display_mci_rec *)
  522.              if  option = 2  then
  523.                 begin
  524.                    clear_mci_info(mci_info);
  525.                    getrec(mci_data,recnumber,mci_info);
  526.                  end;
  527.              with  mci_info  do
  528.                 begin
  529.                    bprint(image_buffer,copy((mci_name),1,20),5,30);
  530.                    bprint(image_buffer,copy((mci_user),1,30),7,30);
  531.                    bprint(image_buffer,copy((mci_password),1,30),9,30);
  532.                    bprint(image_buffer,copy((mci_telephone),1,14),11,30);
  533.                    bprint(image_buffer,copy((mci_local_area),1,5),14,30);
  534.                 end;
  535.           end;
  536.  
  537.    end;
  538.    screen_colors(black,magenta,color);
  539.    bprint(image_buffer,'        ',25,8);
  540.    bprint(image_buffer,' date:            time:          ',25,17);
  541.    bprint(image_buffer,'          ',25,51);
  542.    bprint(image_buffer,'           ',25,64);
  543.    bprint(image_buffer,date,25,24);
  544.    bprint(image_buffer,time,25,41);
  545.    screen_colors(white,black,color);
  546.    send_buffer_to_screen(image_buffer);
  547. end;
  548.  
  549.  
  550.  
  551.  
  552. procedure fprint_old_mci_window;
  553.  
  554. (**************************************************)
  555. (*  The  fprint_old_mci_window  procedure  fills  *)
  556. (*  the old delaer window with a new record.      *)
  557. (**************************************************)
  558.  
  559. const
  560.    space = '                   ';
  561.  
  562. begin
  563.    screen_colors(white,black,color);
  564.    with  mci_info  do
  565.       begin
  566.          fprint(copy((mci_name + space),1,19),14,60);
  567.          fprint(copy((mci_user + space),1,19),15,60);
  568.          fprint(copy((mci_password + space),1,19),16,60);
  569.          fprint(copy((mci_telephone + space),1,19),17,60);
  570.          fprint(copy((mci_local_area + space),1,19),19,60);
  571.       end;
  572. end;
  573.  
  574.  
  575.  
  576. Begin  (* main MCI *)
  577.    load_screen_stack('MCI.SCR',3,top);
  578.    window(1,1,80,25);
  579.    gotoxy(1,1);
  580.    initindex;
  581.    openfiles;
  582.    makewindow(1,1);
  583.       .
  584.       .
  585.       .
  586.    closefiles;
  587. End.
  588.  
  589.  
  590.  
  591.  
  592.